home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / seditQP.tcl.z / seditQP.tcl
Text File  |  2002-07-08  |  6KB  |  218 lines
  1. # seditQP
  2. #
  3. # Crude quoted-printable support for sedit
  4. #
  5. # Copyright (c) 1994 Xerox Corporation.
  6. # Use and copying of this software and preparation of derivative works based
  7. # upon this software are permitted. Any distribution of this software or
  8. # derivative works must comply with all applicable United States export
  9. # control laws. This software is made available AS IS, and Xerox Corporation
  10. # makes no warranty about the software, its performance or its conformity to
  11. # any specification.
  12.  
  13. proc SeditInitMimeType { draft t } {
  14.     # This is really lame.
  15.     # The code from mime.tcl needs to be generalized so it can
  16.     # reparse draft files.
  17.     global sedit exmh
  18.     set id $sedit($t,id)
  19.     if {$exmh($id,action) == "dist"} {
  20.     return
  21.     }
  22.  
  23.     $t mark set cursor insert
  24.     for {set i 1} {1} {incr i} {
  25.     set line [$t get $i.0 $i.end]
  26.     set len [string length $line]
  27.     if [regexp -nocase {content-type:(.*)$} $line match type] {
  28.         return
  29.     }
  30.     if {$len == 0 || [regexp ^-- $line]} {
  31.         break
  32.     }
  33.     }
  34.     SeditMsg $t "MIME type text/plain ; charset=$sedit(charset)"
  35.     SeditMimeType text/plain promote
  36.     $t mark set insert cursor
  37. }
  38.  
  39. proc SeditFixupEncoding { draft t quote } {
  40.     if [catch {open $draft} in] {
  41.     SeditMsg $t $out
  42.     error "Cannot read draft to quote it"
  43.     }
  44.     global mime
  45.     if {[string length $mime(dir)] == 0} {
  46.     SeditMsg $t "Metamail required to quote/encode text"
  47.     error "Metamail required to quote/encode text"
  48.     }
  49.     if [catch {open $draft.new w} out] {
  50.     close $in
  51.     SeditMsg $t $out
  52.     error "Cannot fix encoding: $out"
  53.     }
  54.     if {$quote} {
  55.     SeditMsg $t "Quoting text"
  56.     Exmh_Debug Quoting text
  57.     } else {
  58.     SeditMsg $t "8-bit encoding"
  59.     Exmh_Debug 8-bit encoding
  60.     }
  61.     set state header
  62.     set done 0
  63.     set needCoder 0
  64.     set type text
  65.     set typeActive 0
  66.     set boundaries {}
  67.     for {set len [gets $in line]} {$len >= 0} {set len [gets $in line]} {
  68.     if {$state == "header"} {
  69.         if [regexp -nocase content-transfer-encoding $line] {
  70.         Exmh_Debug coding already done
  71.         set done 1
  72.         }
  73.         if {[regexp "^\[ \t]" $line] && $typeActive} {
  74.         append type $line
  75.         }
  76.         if [regexp -nocase {content-type:(.*)$} $line match type] {
  77.         set typeActive 1
  78.         } else {
  79.         set typeActive 0
  80.         }
  81.         if {$len == 0 || [regexp ^-- $line]} {
  82.         set state body
  83.         set params [split $type \;]
  84.         set type [string tolower [string trim [lindex $params 0]]]
  85.         Exmh_Debug type $type
  86.         foreach sub [lrange $params 1 end] {
  87.             if [regexp {([^=]+)=(.+)} $sub match key val] {
  88.             set key [string trim [string tolower $key]]
  89.             set val [string trim $val \ \"]
  90.             if {[string compare $key boundary] == 0} {
  91.                 # push new boundary onto the stack
  92.                 set boundaries [linsert $boundaries 0 $val]
  93.             }
  94.             }
  95.         }
  96.         if {! $done && [regexp -nocase text $type]} {
  97.             set needCoder 1
  98.             Exmh_Debug needCoder $type
  99.         }
  100.         }
  101.  
  102.         if {$needCoder} {
  103.         set savedLine $line
  104.         } else {
  105.         if {$quote} {
  106.             puts $out [SeditQuoteHeader $line]
  107.         } else {
  108.             puts $out $line
  109.         }
  110.         }
  111.     } else {
  112.         foreach b $boundaries {
  113.         if [regexp ^--$b\(--\)?\$ $line match alldone] {
  114.             catch {close $encoder}
  115.             catch {unset encoder}
  116.             set type text
  117.             if {[string compare $alldone --] == 0} {
  118.             # should pop boundary stack
  119.             set done 1
  120.             } else {
  121.             set state header
  122.             set typeActive 0
  123.             set type text
  124.             set done 0
  125.             }
  126.             set needCoder 0
  127.             Exmh_Debug no coder $line
  128.         }
  129.         }
  130.         if {$needCoder} {
  131.         set needCoder 0
  132.         Exmh_Debug coding
  133.         if {$quote} {
  134.             puts $out "Content-Transfer-Encoding: quoted-printable"
  135.             puts $out $savedLine
  136.             flush $out
  137.             if [catch {open "|$mime(encode) -q >@ $out" w} encoder] {
  138.             SeditMsg $t $encoder
  139.             close $in
  140.             close $out
  141.             error "Cannot run $mime(encode)"
  142.             }
  143.         } else {
  144.             puts $out "Content-Transfer-Encoding: 8bit"
  145.             puts $out $savedLine
  146.         }
  147.         }
  148.         if [info exists encoder] {
  149.         puts $encoder $line
  150.         } else {
  151.         puts $out $line
  152.         }
  153.     }
  154.     }
  155.     catch {close $encoder}
  156.     close $out
  157.     close $in
  158.     Mh_Rename $draft.new $draft
  159. }
  160. proc SeditQuoteHeader { line } {
  161.     global sedit
  162.     set newline {}
  163.     set begin 1
  164.     if [regexp {^([     ]+)(.*)} $line match space value] {
  165.     set newline $space
  166.     set line $value
  167.     } elseif [regexp {^([^:     ]+:[     ]*)(.*)} $line match key value] {
  168.     set newline $key
  169.     set line $value
  170.     }
  171.     set hithit 0
  172.     while {[string length $line] > 0} {
  173.     if [regexp -indices {^([^][\(\)<>@,;:"/\?\.=     ]*)([][\(\)<>@,;:"/\?\.=     ]*)} $line match word special] {
  174.         set x [expr [lindex $special 1]+1]
  175.         set word [eval {string range $line} $word]
  176.         set special [eval {string range $line} $special]
  177.         if {[string length $special] == 0} {
  178.         set line {}
  179.         } else {
  180.         set line [string range $line $x end]
  181.         }
  182.         set hit 0
  183.         foreach char [split $word {}] {
  184.         scan $char %c code
  185.         if {$code > 127} {
  186.             set hit 1
  187.             Exmh_Debug Hit $code $char
  188.             break
  189.         }
  190.         }
  191.         if {! $hit} {
  192.         set hithit 0
  193.         append newline $word $special
  194.         } else {
  195.         append newline =?$sedit(charset)?Q?
  196.         if {$hithit} {
  197.             append newline _
  198.         }
  199.         foreach char [split $word {}] {
  200.             scan $char %c code
  201.             if {$code > 127 || $char == "_" || $char == "=" || $char == {?}} {
  202.             append newline [format =%X $code]
  203.             } else {
  204.             append newline $char
  205.             }
  206.         }
  207.         append newline ?= $special
  208.         set hithit 1
  209.         }
  210.     } else {
  211.         Exmh_Debug Fail <$line>
  212.         append newline $line
  213.         set line {}
  214.     }
  215.     }
  216.     return $newline
  217. }
  218.